home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / CorePackages / www.tcl < prev   
Encoding:
Text File  |  2001-01-19  |  21.3 KB  |  675 lines
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  AlphaTcl - core Tcl engine
  4.  # 
  5.  #  FILE: "www.tcl"
  6.  #                                    created: 01-01-05 03.08.54 
  7.  #                                last update: 01-01-19 06.45.05 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <vince@santafe.edu>
  10.  #    mail: 317 Paseo de Peralta, Santa Fe, NM 87501
  11.  #     www: <http://www.santafe.edu/~vince/>
  12.  #  
  13.  #  modified by  rev reason
  14.  #  -------- --- --- -----------
  15.  #  4/9/97   VMD 1.0 original
  16.  # ###################################################################
  17.  ##
  18.  
  19.  
  20. proc forceLoadAE {} {
  21.     return
  22.     # Comment out the above line if your machine is very slow.
  23.     alpha::package require tclAE
  24.     global ALPHA HOME
  25.     catch {makeAlis [file join $HOME $ALPHA]}
  26. }
  27.  
  28. proc htmlView {filename} {
  29.     global viewHtmlUsing alpha::platform browserSig htmlViewer
  30.     if {${alpha::platform} == "alpha"} {
  31.     # Is the browserSig set yet?
  32.     if {$browserSig == ""} {
  33.         app::getSig "Please locate your browser :" browserSig
  34.     } 
  35.     # Make sure that the .html file is of type $browserSig. 
  36.     # We also need to delete any resource fork to ensure
  37.     # that it gets sent to the browser, not Alpha.
  38.     setFileInfo $filename type TEXT
  39.     setFileInfo $filename creator $browserSig
  40.     setFileInfo $filename resourcelen
  41.     }
  42.     eval $htmlViewer($viewHtmlUsing) [list $filename]
  43. }
  44.  
  45. proc htmlHelpViewer {filename} {
  46.     global alpha::platform
  47.     if {${alpha::platform} != "alpha" || [catch {nameFromAppl hbwr}]} {
  48.     # This shouldn't have been presented as an option ...
  49.     alertnote "Sorry, the MacOS Help viewer could not be found."
  50.     error "The MacOS Help Viewer could not be found."
  51.     }
  52.     app::launchBack hbwr
  53.     sendOpenEvent noReply 'hbwr' $filename
  54.     switchTo 'hbwr'
  55. }
  56.  
  57. proc htmlChooseViewer {filename} {
  58.     global htmlViewer
  59.     set prompt "View  \"[file tail $filename]\"  using … "
  60.     set options [lremove [array names htmlViewer] "Choose each time"]
  61.     lappend options "(Set WWW preferences to avoid this dialog …)"
  62.     set val [listpick -L "Browser" -p $prompt $options]
  63.     if {$val == "(Set WWW preferences to avoid this dialog …)"} {
  64.     dialog::preferences preferences "WWW"
  65.     } else {
  66.     eval $htmlViewer($val) [list $filename]
  67.     }
  68. }
  69.  
  70. namespace eval url {}
  71.  
  72. ## 
  73.  # -------------------------------------------------------------------------
  74.  # 
  75.  # "url::mailto" --
  76.  # 
  77.  #  Generate a mailto url from the given argument pairs.  You can then
  78.  #  pass the result to 'url::execute' to take action.  Note that very
  79.  #  long mailto urls seem not to be handled properly, so you may wish
  80.  #  to check the length of the 'body' field, if given and take a different
  81.  #  action (e.g. put the body on the clip board for the user to handle
  82.  #  manually).
  83.  #  
  84.  #  A typical use is:
  85.  #  
  86.  #  url::execute [url::maito vince@santafe.edu subject hello body goodbye]
  87.  # -------------------------------------------------------------------------
  88.  ##
  89. proc url::mailto {address args} {
  90.     set url "mailto:$address"
  91.     set divider "?"
  92.     newforeach {arg value} $args {
  93.     append url $divider $arg = [quote::Url $value]
  94.     set divider "&"
  95.     }
  96.     return $url
  97. }
  98.  
  99. # This should carry out the default action of opening/clicking-on
  100. # a url
  101. proc url::execute {url} {
  102.     icURL $url
  103. }
  104.  
  105. # For url's which ought to be downloaded (e.g. files), this
  106. # procedure will try to carry that out in preference to opening.
  107. proc url::download {url} {
  108.     global downloadFolder
  109.     url::fetch $url $downloadFolder
  110. }
  111.  
  112. proc url::parse {url} {
  113.     if {![regexp {^([^:]+)://(.*)$} $url dmy type rest]} {
  114.     alertnote "I couldn't understand that url: '$url'"
  115.     error ""
  116.     }
  117.     return [list $type $rest]
  118. }
  119.  
  120. proc url::parseFtp {p array} {
  121.     # format is user:pass@host/path
  122.     if {[set at [string first "@" $p]] != -1} {
  123.     # have user etc.
  124.     if {[string first ":" $p] < $at} {
  125.         # have password
  126.         regexp {([^:]+):([^@]+)@(.*)$} $p dummy user pass p
  127.     } else {
  128.         # no password
  129.         regexp {([^@]+)@(.*)$} dummy user p
  130.         set pass ""
  131.     }
  132.     } else {
  133.     set user "anonymous"
  134.     if {[catch {set pass [icGetPref Email]}] || ![string length $pass]} {
  135.         set pass "anonymous"
  136.     }
  137.     }
  138.     regexp {([^/]+)($|/$|/(.*/)([^/]*)$)} $p dummy host dummy path file
  139.     upvar $array a
  140.     array set a [list user $user pass $pass host $host path $path file $file]
  141. }
  142.  
  143. proc url::store {url file} {
  144.     set t [url::parse $url]
  145.     set type [lindex $t 0]
  146.     set rest [lindex $t 1]    
  147.     switch -- $type {
  148.     "ftp" {
  149.         url::parseFtp $rest i
  150.         set i(file) [file tail $file]
  151.         ftpStore "$file" $i(host) "$i(path)$i(file)" $i(user) $i(pass)
  152.     }
  153.     default {
  154.         alertnote "Don't know how to put '$type' url's"
  155.         error ""
  156.     }
  157.     }
  158. }
  159.  
  160. proc url::fetchFrom {url localdir {file ""}} {
  161.     url::fetch ${url}${file} $localdir $file    
  162. }
  163.  
  164.  
  165. ## 
  166.  # -------------------------------------------------------------------------
  167.  # 
  168.  # "url::fetch" --
  169.  # 
  170.  #  Get a precise url into a localdir/file.  The url may be a directory,
  171.  #  in which case we retrieve a listing.
  172.  #  
  173.  #  Use url::fetchFrom to fetch a file from a given url-location.
  174.  #  
  175.  #  Note 'Geni' is the sig of a wish applet I wrote which is augmented
  176.  #  with a few procedures to download files via http. 
  177.  #  Of course it needs the user to install Sun's latest
  178.  #  release of Tcl/Tk
  179.  # -------------------------------------------------------------------------
  180.  ##
  181. proc url::fetch {url localdir {file ""}} {
  182.     set t [url::parse $url]
  183.     set type [lindex $t 0]
  184.     set rest [lindex $t 1]
  185.     if {$file != ""} {
  186.     set to [file join $localdir $file]
  187.     } else {
  188.     set to $localdir
  189.     }
  190.     
  191.     switch -- $type {
  192.     "ftp" {
  193.         url::parseFtp $rest i
  194.         catch {file mkdir [file dirname $localdir]}
  195.         if {[regexp "/$" "$i(path)$i(file)"]} {
  196.         # directory
  197.         ftpList $to $i(host) $i(path) $i(user) $i(pass)
  198.         } else {
  199.         ftpFetch $to $i(host) "$i(path)$i(file)" $i(user) $i(pass)
  200.         }
  201.     }
  202.     "http" {
  203.         if {[file isdirectory $to]} {
  204.         global file::separator
  205.         if {[regexp "\\${file::separator}\$" $url]} {
  206.             set to [file join $to index.html]
  207.         } else {
  208.             set to [file join $to [file tail $url]]
  209.         }
  210.         }
  211.         httpFetch $url $to
  212.     }
  213.     default {
  214.         alertnote "Don't know how to fetch '$type' url's"
  215.         error ""
  216.     }
  217.     }
  218.     return $type
  219. }
  220.  
  221. proc httpFetch {url to} {
  222.     global useTclServiceForHttp
  223.     if {[info exists useTclServiceForHttp] && $useTclServiceForHttp} {
  224.     httpCopy ${url} $to
  225.     return
  226.     }
  227.     global httpDownloadSig httpDownloadSigs
  228.     # force loading of AE code to avoid some timeout/ae problems
  229.     if {[info tclversion] < 8.0} { forceLoadAE }
  230.     app::launchAnyOfThese $httpDownloadSigs httpDownloadSig
  231.     if {[file exists $to] && [file isfile $to]} {
  232.     if {[dialog::yesno "Replace [file tail $to]?"]} {
  233.         file delete $to
  234.     } else {
  235.         error "Abort download."
  236.     }
  237.     }
  238.     set fid [alphaOpen $to w]
  239.     close $fid
  240.     if {$httpDownloadSig == "Geni"} {
  241.     switchTo '$httpDownloadSig'
  242.     set res [AEBuild -r -t 30000 '$httpDownloadSig' misc dosc ---- \
  243.       "“[list Http_Copy ${url} $to]”"]
  244.     switchTo 'ALFA'
  245.     if {[string match "*Not found*" $res]} {
  246.         catch {file delete $to}
  247.         error "File not found on http server."
  248.     }
  249.     } else {
  250.     AEBuild -r -t 30000 '$httpDownloadSig' WWW! OURL ---- "“${url}”" \
  251.       INTO [makeAlis "$to"]
  252.     }
  253. }
  254.  
  255. # Copy a URL to a file and print meta-data
  256. proc httpCopy { url file {chunk 4096} } {
  257.     package require http
  258.     set out [alphaOpen $file w]
  259.     set token [http::geturl $url -channel $out -progress httpProgress \
  260.       -blocksize $chunk]
  261.     close $out
  262.     upvar #0 $token state
  263.     set max 0
  264.     foreach {name value} $state(meta) {
  265.     if {[string length $name] > $max} {
  266.         set max [string length $name]
  267.     }
  268.     if {[regexp -nocase ^location$ $name]} {
  269.         # Handle URL redirects
  270.         message "Location:$value"
  271.         return [httpCopy [string trim $value] $file $chunk]
  272.     }
  273.     }
  274.     incr max
  275.     foreach {name value} $state(meta) {
  276.     #puts [format "%-*s %s" $max $name: $value]
  277.     }
  278.     return $token
  279. }
  280.  
  281. proc httpProgress {args} {
  282.     message $args
  283. }
  284.  
  285. ## 
  286.  # -------------------------------------------------------------------------
  287.  # 
  288.  # "ftpFetch" --
  289.  # 
  290.  #  Downloads a remote file to your disk. 
  291.  #  
  292.  # -------------------------------------------------------------------------
  293.  ##
  294. proc ftpFetch {localName host path user password {replyHandler ""}} {
  295.     global useTclServiceForFtp
  296.     file::ensureDirExists [file dirname $localName]
  297.     if {[info exists useTclServiceForFtp] && $useTclServiceForFtp} {
  298.     package require ftp
  299.     set s [ftp::Open $host $user $password -output ftpDisplayMsg]
  300.     if {$s == -1} {
  301.         error "Failed to open ftp connection to $host"
  302.     }
  303.     ftp::Type $s binary
  304.     if {![ftp::Get $s $path $localName]} {
  305.         ftp::Close $s
  306.         error "Problem fetching file"
  307.     }
  308.     ftp::Close $s
  309.     if {[string length $replyHandler]} {
  310.         eval $replyHandler
  311.     }
  312.     return
  313.     }
  314.     global ftpSig ftpSigs
  315.     # force loading of AE code to avoid some timeout/ae problems
  316.     if {[info tclversion] < 8.0} { forceLoadAE }
  317.     app::launchAnyOfThese $ftpSigs ftpSig "Please locate your ftp application:"
  318.     if {[file exists $localName]} {
  319.     file delete $localName
  320.     }
  321.     if {$ftpSig == "FTCh" || $ftpSig == "Arch"} {
  322.     set localName "[file dirname $localName]:"
  323.     set flag -r
  324.     if {$replyHandler != ""} {
  325.         currentReplyHandler $replyHandler
  326.         set flag -q
  327.     }
  328.     }
  329.     switch -- $ftpSig {
  330.     Arch -
  331.     FTCh {AEBuild $flag -t 30000 '$ftpSig' Arch Ftch FTPh "“$host”" FTPc "“$path”" ArGU "“$user”" ArGp "“$password”" ---- [makeAlis $localName]}
  332.     Woof {
  333.         if {$replyHandler == "" || ![checkNetFinderVersion]} {
  334.         set flag -r
  335.         if {$replyHandler != ""} {
  336.             currentReplyHandler $replyHandler
  337.             set flag -q
  338.         }
  339.         close [open $localName "w"]
  340.         AEBuild $flag -t 30000 'Woof' GURL GURL ---- "“ftp://${user}:${password}@${host}/${path}”" dest [makeAlis $localName]
  341.         return
  342.         }
  343.         global PREFS ALPHA
  344.         set Woof [temp::unique ftptmp Woof]
  345.         set fid [open $Woof "w"]
  346.         puts $fid "auto result;"
  347.         puts $fid "auto script;"
  348.         puts $fid "auto script1;"
  349.         puts $fid "auto ftpRef = NFCreateFTPInstance();"
  350.         puts $fid "NFLoadModuleConstants();"
  351.         puts $fid "do \{"
  352.         puts $fid "if (result = NFConnect(ftpRef, \"$host\", 21, \"$user\", \"$password\"), result != 0) break;"
  353.         puts $fid "if (result = NFReceiveFile(ftpRef, \"$path\", eASCIIType, \"$localName\", eText, NULL, NULL), result != 0) break;"
  354.         puts $fid "\} while(0);"
  355.         puts $fid "NFDisconnect(ftpRef);"
  356.         puts $fid "NFDeleteFTPInstance(ftpRef);"
  357.         puts $fid "script = \"tell app \\\"$ALPHA\\\"\\r ignoring application responses \\r DoScript \\\"$replyHandler aevt\\\\\\\\\\\\\\\\ansr\\\\\\\\\\\\\\\\{'----':\" + string(result) + \"\\\\\\\\\\\\\\\\}\";"
  358.         puts $fid "script1 = \"; file delete \{$Woof\}\\\"\\r end ignoring\\r end tell\";"
  359.         puts $fid "MICI.ExecuteScript(script + script1);"
  360.         close $fid
  361.         setFileInfo $Woof type ICI!
  362.         sendOpenEvent noReply 'Woof' $Woof  
  363.     }
  364.     }
  365. }
  366.  
  367. ## 
  368.  # -------------------------------------------------------------------------
  369.  # 
  370.  # "ftpStore" --
  371.  # 
  372.  #  Uploads a file to a remote ftp server.
  373.  #  
  374.  # -------------------------------------------------------------------------
  375.  ##
  376. proc ftpStore {localName host path user password {replyHandler ftpHandleReply}} {
  377.     global useTclServiceForFtp
  378.     if {[info exists useTclServiceForFtp] && $useTclServiceForFtp} {
  379.     package require ftp
  380.     set s [ftp::Open $host $user $password -output ftpDisplayMsg]
  381.     if {$s == -1} {
  382.         error "Failed to open ftp connection to $host"
  383.     }
  384.     ftp::Type $s binary
  385.     # Note that 'Put' will overwrite existing files.
  386.     if {[catch {ftp::Put $s $localName $path}]} {
  387.         # Most likely cause is sub-paths not existing.
  388.         set pieces [file split [file dirname $path]]
  389.         set sub {}
  390.         foreach piece $pieces {
  391.         set sub [file join $sub $piece]
  392.         ftp::MkDir $s $sub
  393.         }
  394.         ftp::Put $s $localName $path
  395.     }
  396.     ftp::Close $s
  397.     return
  398.     }
  399.     global ftpSig ftpSigs
  400.     # force loading of AE code to avoid some timeout/ae problems
  401.     if {[info tclversion] < 8.0} { forceLoadAE }
  402.     app::launchAnyOfThese $ftpSigs ftpSig "Please locate your ftp application:"
  403.     switch -- $ftpSig {
  404.     Arch -
  405.     FTCh {
  406.         currentReplyHandler $replyHandler
  407.         AEBuild -q -t 30000 '$ftpSig' Arch Stor ---- [makeAlis $localName] FTPh "“$host”" FTPc "“$path”" ArGU "“$user”" ArGp "“$password”"
  408.     }
  409.     Woof {
  410.         set dirpath [string range $path 0 [expr {[string last / $path] - 1}]]
  411.         if {![checkNetFinderVersion]} {
  412.         currentReplyHandler $replyHandler
  413.         AEBuild -q -t 30000 '$ftpSig' PURL PURL ---- [makeAlis $localName] dest "“ftp://${user}:${password}@${host}/${dirpath}”"
  414.         return
  415.         }
  416.         global PREFS ALPHA
  417.         set Woof [temp::unique ftptmp Woof]
  418.         set fid [open $Woof "w"]
  419.         puts $fid "auto result;"
  420.         puts $fid "auto script;"
  421.         puts $fid "auto script1;"
  422.         puts $fid "auto ftpRef = NFCreateFTPInstance();"
  423.         puts $fid "NFLoadModuleConstants();"
  424.         puts $fid "do \{"
  425.         puts $fid "if (result = NFConnect(ftpRef, \"$host\", 21, \"$user\", \"$password\"), result != 0) break;"
  426.         puts $fid "if (result = NFChangeWorkingDirectory(ftpRef, \"$dirpath\"), result != 0) break;"
  427.         puts $fid "if (result = NFSendFile(ftpRef, \"$path\", eASCIIType, \"$localName\", eText, NULL, NULL), result != 0) break;"
  428.         puts $fid "\} while(0);"
  429.         puts $fid "NFDisconnect(ftpRef);"
  430.         puts $fid "NFDeleteFTPInstance(ftpRef);"
  431.         puts $fid "script = \"tell app \\\"$ALPHA\\\"\\r ignoring application responses \\r DoScript \\\"$replyHandler aevt\\\\\\\\\\\\\\\\ansr\\\\\\\\\\\\\\\\{'----':\" + string(result) + \"\\\\\\\\\\\\\\\\}\";"
  432.         puts $fid "script1 = \"; file delete \{$Woof\}\\\"\\r end ignoring\\r end tell\";"
  433.         puts $fid "MICI.ExecuteScript(script + script1);"
  434.         close $fid
  435.         setFileInfo $Woof type ICI!
  436.         sendOpenEvent noReply 'Woof' $Woof  
  437.     }
  438.     }
  439. }
  440.  
  441. ## 
  442.  # -------------------------------------------------------------------------
  443.  # 
  444.  # "ftpList" --
  445.  # 
  446.  #  Saves the file listing of a remote directory to a file. Uses a trick 
  447.  #  for Fetch when saving the file. First the files are listed in a text
  448.  #  window in Fetch. This window is then saved to the disk.
  449.  #  
  450.  # -------------------------------------------------------------------------
  451.  ##
  452. proc ftpList {localName host path user password {replyHandler ""}} {
  453.     global useTclServiceForFtp
  454.     if {[info exists useTclServiceForFtp] && $useTclServiceForFtp} {
  455.     package require ftp
  456.     set s [ftp::Open $host $user $password -output ftpDisplayMsg]
  457.     if {$s == -1} {
  458.         error "Failed to open ftp connection to $host"
  459.     }
  460.     ftp::Type $s binary
  461.     if {[string length $path]} {
  462.         if {![regexp {/$} $path]} {append path "/"}
  463.     }
  464.     set res [ftp::List $s $path]
  465.     ftp::Close $s
  466.     set fd [alphaOpen $localName "w"]
  467.     puts $fd [join [concat "dummy" $res "dummy"] "\n"]
  468.     close $fd
  469.     if {[string length $replyHandler]} {
  470.         eval $replyHandler
  471.     }
  472.     return
  473.     }
  474.     global ftpSig ftpSigs
  475.     # force loading of AE code to avoid some timeout/ae problems
  476.     if {[info tclversion] < 8.0} { forceLoadAE }
  477.     app::launchAnyOfThese $ftpSigs ftpSig "Please locate your ftp application:"
  478.     switch -- $ftpSig {
  479.     Arch -
  480.     FTCh {
  481.         close [open $localName "w"]
  482.          set flag -r
  483.         if {$replyHandler != ""} {
  484.         currentReplyHandler $replyHandler
  485.         set flag -q
  486.         }
  487.         if {$ftpSig == "Arch"} {
  488.         AEBuild $flag -t 30000 '$ftpSig' Arch List FTPh "“$host”" FTPc "“$path”" ArGU "“$user”" ArGp "“$password”" {----} [makeAlis $localName]
  489.         }
  490.         if {$ftpSig == "FTCh"} {
  491.         AEBuild -r -t 3000 '$ftpSig' Arch List FTPh "“$host”" FTPc "“$path”" ArGU "“$user”" ArGp "“$password”" {----} [makeAlis $localName]
  492.         AEBuild -r -t 3000 'FTCh' FTCh VwFL ---- "obj{want:type(cFWA), from:'null'(), form:name, seld:“$host”}"
  493.         AEBuild -r -t 3000 'FTCh' core save ---- "obj{want:type(cFWC), from:'null'(), form:indx, seld:long(1)}" kfil [makeAlis $localName]
  494.         AEBuild $flag -t 3000 'FTCh' core clos ---- "obj{want:type(cFWC), from:'null'(), form:indx, seld:long(1)}" savo "yes"
  495.         }
  496.         
  497.         if {$ftpSig == "Arch"} {
  498.         set newname [file rootname $localName]#1[file extension $localName]
  499.         getFileInfo $localName arr
  500.         if {$arr(datalen) == 0 && [file exists $newname]} {
  501.             file delete $localName
  502.             file rename $newname $localName
  503.         }
  504.         }
  505.     }
  506.     Woof {
  507.         if {$replyHandler == ""} {
  508.         alertnote "This doesn't work with NetFinder."
  509.         error "no reply handler"
  510.         }
  511.         global PREFS ALPHA
  512.         if {![checkNetFinderVersion]} {
  513.         alertnote "NetFinder 2.1.2 or later required."
  514.         error "too old NetFinder"
  515.         }
  516.         close [open $localName "w"]
  517.         set Woof [temp::unique ftptmp Woof]
  518.         set fid [open $Woof "w"]
  519.         puts $fid "auto file;"
  520.         puts $fid "auto result;"
  521.         puts $fid "auto item;"
  522.         puts $fid "auto script;"
  523.         puts $fid "auto script1;"
  524.         puts $fid {auto listing = [array];}
  525.         puts $fid "auto ftpRef = NFCreateFTPInstance();"
  526.         puts $fid "file = fopen(\"$localName\", \"w\");"
  527.         puts $fid "NFLoadModuleConstants();"
  528.         puts $fid "do \{"
  529.         puts $fid "if (result = NFConnect(ftpRef, \"$host\", 21, \"$user\", \"$password\"), result != 0) break;"
  530.         puts $fid "if (result = NFListDirectory(ftpRef, \"$path\", 1, &listing), result != 0) break;"
  531.         puts $fid "forall(item in listing) \{"
  532.         puts $fid "if ((item.kind & eDirectoryItem) == eDirectoryItem) fprintf(file, \"d \");"
  533.         puts $fid "else if ((item.kind & eLinkItem) == eLinkItem) fprintf(file, \"l \");"
  534.         puts $fid "else fprintf(file, \"  \");"
  535.         puts $fid "fprintf(file, \"Ab 0 0 %s\", item.name);"
  536.         puts $fid "if ((item.kind & eLinkItem) == eLinkItem) fprintf(file, \" -> %s\", item.link);"
  537.         puts $fid "fprintf(file, \"\\n\");"
  538.         puts $fid "\}"
  539.         puts $fid "\} while(0);"
  540.         puts $fid "NFDisconnect(ftpRef);"
  541.         puts $fid "NFDeleteFTPInstance(ftpRef);"
  542.         puts $fid "close(file);"
  543.         puts $fid "script = \"tell app \\\"$ALPHA\\\"\\r ignoring application responses \\r DoScript \\\"$replyHandler aevt\\\\\\\\\\\\\\\\ansr\\\\\\\\\\\\\\\\{'----':\" + string(result) + \"\\\\\\\\\\\\\\\\}\";"  
  544.         puts $fid "script1 = \"; file delete \{$Woof\}\\\"\\r end ignoring\\r end tell\";"
  545.         puts $fid "MICI.ExecuteScript(script + script1);"
  546.         close $fid
  547.         setFileInfo $Woof type ICI!
  548.         sendOpenEvent noReply 'Woof' $Woof  
  549.     }
  550.     default {
  551.         alertnote "This doesn't work with [file tail [nameFromAppl $ftpSig]]."
  552.     }
  553.     }
  554. }
  555.  
  556. # Checks the version of NetFinder
  557. proc checkNetFinderVersion {} {
  558.      global NetFinderVersion
  559.      if {![info exists NetFinderVersion]} {
  560.     alpha::package require version
  561.     # if error, assume recent enough.
  562.     if {[catch {file::version -creator Woof} NetFinderVersion]} {
  563.         set NetFinderVersion "2.1.2"
  564.         return 1
  565.     }
  566.      }
  567.      return [expr {[alpha::package vcompare $NetFinderVersion "2.1.2"] >= 0}]
  568. }
  569.  
  570. ## 
  571.  # -------------------------------------------------------------------------
  572.  # 
  573.  # "ftpHandleReply" --
  574.  # 
  575.  #  Handles the reply when using ftpStore.
  576.  #  
  577.  # -------------------------------------------------------------------------
  578.  ##
  579. proc ftpHandleReply {reply} {
  580.     set ans [string range $reply 11 end]
  581.     if {[regexp {^errs:“([^”]+)”} $ans dum err]} {
  582.     # Fetch error
  583.     if {[regexp {Error: (.*)} $err dum err2]} {set err $err2}
  584.     switchTo 'ALFA'
  585.     alertnote "Ftp error: $err"
  586.     } elseif {[regexp {^'----':-?([0-9]*)} $ans dum err]} {
  587.     if {$err != "0"} {
  588.         # Anarchie error.
  589.         switchTo 'ALFA'
  590.         alertnote "Ftp error: $err"
  591.     } else {
  592.         message "Document uploaded to ftp server."
  593.     }
  594.     } elseif {$ans == "\\\}"} {
  595.     message "Document uploaded to ftp server."
  596.     } else {
  597.     return 0
  598.     }
  599.     return 1
  600. }
  601.  
  602. # Used by Tcl's 'ftp' package.
  603. proc ftpDisplayMsg {s msg {state ""}} {
  604.     switch -- $state {
  605.     data    {::message $msg}
  606.     control    {::message $msg}
  607.     error    {::message $msg}
  608.     default {::message $msg}
  609.     }    
  610. }
  611.  
  612. ## 
  613.  # -------------------------------------------------------------------------
  614.  #     
  615.  # "GURLHandler" --
  616.  #    
  617.  #  Handle general GURL events by extracting the type 'ftp', 'http',… and
  618.  #  calling a procedure ${type}GURLHandler with a single parameter which is
  619.  #  the extracted resource.  Can be put to more general use.  You must
  620.  #  register this proc as an event handler if you want to use it.  Do this
  621.  #  with:
  622.  #   
  623.  #    eventHandler GURL GURL GURLHandler
  624.  #    
  625.  # -------------------------------------------------------------------------
  626.  ##
  627. proc GURLHandler {msg} {
  628.     if {![regsub {.*“(.*)”.*} $msg {\1} gurl]} {
  629.     alertnote "Didn't understand GURL: $msg"
  630.     return
  631.     }
  632.     set GURLtype [lindex [split $gurl ":"] 0]
  633.     set GURLvalue [string range $gurl [expr {1+[string length $GURLtype]}] end]
  634.     if {[catch {${GURLtype}GURLHandler $GURLvalue} msg]} {
  635.     message $msg
  636.     }
  637. }
  638.  
  639. proc url::browserWindow {} {
  640.     global tcl_platform browserSig
  641.     switch -- $tcl_platform(platform) {
  642.     "macintosh" {
  643.         if {![regexp {\[([0-9]+)} [AEBuild -r '$browserSig' WWW! LSTW] "" winnum]} {
  644.         error "No browser window."
  645.         }
  646.         # returns window info
  647.         regexp {\[([^ ]+)} [AEBuild -r '$browserSig' WWW! WNFO ---- $winnum] "" winurl
  648.         set winurl [string trim $winurl "“”,"]
  649.         if {$winurl == "'TEXT'()"} {
  650.         error "Empty browser window."
  651.         }
  652.         return $winurl
  653.     }
  654.     "windows" {
  655.         if {[info exists browserSig]} {
  656.         set root [string tolower [file rootname [file tail $browserSig]]]
  657.         } else {
  658.         set root iexplore
  659.         }
  660.         set root [string trim $root ".0123456789"]
  661.         # If multiple iexplore instances are running, this seems
  662.         # to pick the first?  This should work for 'iexplore' and
  663.         # 'netscape' names.
  664.         set info [dde request $root WWW_GetWindowInfo 1]
  665.         set url [lindex [split $info \"] 1]
  666.         return $url
  667.     }
  668.     "unix" {
  669.         error "Sorry, this is unimplemented.  Please contribute\
  670.           a suitable implementation!"
  671.     }
  672.     }
  673. }
  674.  
  675.